home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / FSTR.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  18.1 KB  |  699 lines
  1. /*
  2.  * File: fstr.r
  3.  *  Contents: center, detab, entab, left, map, repl, reverse, right, trim
  4.  */
  5.  
  6.  
  7. /*
  8.  * macro used by center, left, right
  9.  */
  10. #begdef FstrSetup
  11.    /*
  12.     * s1 must be a string.  n must be a non-negative integer and defaults
  13.     *  to 1.  s2 must be a string and defaults to a blank.
  14.     */
  15.    if !cnv:string(s1) then
  16.       runerr(103,s1)
  17.    if !def:C_integer(n,1) then
  18.       runerr(101, n)
  19.    if !def:tmp_string(s2,blank) then
  20.       runerr(103, s2)
  21.  
  22.    abstract {
  23.       return string
  24.       }
  25.    body {
  26.       register char *s, *st;
  27.       word slen;
  28.       char *sbuf, *s3;
  29.  
  30.       if (n < 0) {
  31.          irunerr(205,n);
  32.          errorfail;
  33.          }
  34.       /*
  35.        * The padding string is null; make it a blank.
  36.        */
  37.       if (StrLen(s2) == 0)
  38.          s2 = blank;
  39.    /* } must be supplied */
  40. #enddef
  41.  
  42.  
  43. "center(s1,i,s2) - pad s1 on left and right with s2 to length i."
  44.  
  45. function{1} center(s1,n,s2)
  46.    FstrSetup /* includes body { */
  47.       {
  48.       word hcnt;
  49.  
  50.       /*
  51.        * If we are extracting the center of a large string (not padding),
  52.        * just construct a descriptor.
  53.        */
  54.       if (n <= StrLen(s1)) {
  55.          return string(n, StrLoc(s1) + ((StrLen(s1)-n+1)>>1));
  56.          }
  57.  
  58.       /*
  59.        * Get space for the new string.  Start at the right
  60.        *  of the new string and copy s2 into it from right to left as
  61.        *  many times as will fit in the right half of the new string.
  62.        */
  63.       Protect(sbuf = alcstr(NULL, n), runerr(0));
  64.  
  65.       slen = StrLen(s2);
  66.       s3 = StrLoc(s2);
  67.       hcnt = n / 2;
  68.       s = sbuf + n;
  69.       while (s > sbuf + hcnt) {
  70.          st = s3 + slen;
  71.          while (st > s3 && s > sbuf + hcnt)
  72.             *--s = *--st;
  73.          }
  74.  
  75.       /*
  76.        * Start at the left end of the new string and copy s1 into it from
  77.        *  left to right as many time as will fit in the left half of the
  78.        *  new string.
  79.        */
  80.       s = sbuf;
  81.       while (s < sbuf + hcnt) {
  82.          st = s3;
  83.          while (st < s3 + slen && s < sbuf + hcnt)
  84.             *s++ = *st++;
  85.          }
  86.  
  87.       slen = StrLen(s1);
  88.       if (n < slen) {
  89.          /*  
  90.           * s1 is larger than the field to center it in.  The source for the
  91.           *  copy starts at the appropriate point in s1 and the destination
  92.           *  starts at the left end of of the new string.
  93.           */
  94.          s = sbuf;
  95.          st = StrLoc(s1) + slen/2 - hcnt + (~n&slen&1);
  96.          }
  97.       else {
  98.          /*
  99.           * s1 is smaller than the field to center it in.  The source for the
  100.           *  copy starts at the left end of s1 and the destination starts at
  101.           *  the appropriate point in the new string.
  102.           */
  103.          s = sbuf + hcnt - slen/2 - (~n&slen&1);
  104.          st = StrLoc(s1);
  105.          }
  106.       /*
  107.        * Perform the copy, moving min(*s1,n) bytes from st to s.
  108.        */
  109.       if (slen > n)
  110.          slen = n;
  111.       while (slen-- > 0)
  112.          *s++ = *st++;
  113.  
  114.       /*
  115.        * Return the new string.
  116.        */
  117.       return string(n, sbuf);
  118.       } }
  119. end
  120.  
  121.  
  122. "detab(s,i,...) - replace tabs with spaces, with stops at columns indicated."
  123.  
  124. function{1} detab(s,i[n])
  125.  
  126.    if !cnv:string(s) then
  127.       runerr(103,s)
  128.  
  129.    abstract {
  130.       return string
  131.       }
  132.  
  133.    body {
  134.       tended char *in, *out, *iend;
  135.       C_integer last, interval, col, target, expand, j;
  136.       dptr tablst;
  137.       dptr endlst;
  138.       int is_expanded = 0;
  139.       char c;
  140.  
  141.       for (j=0; j<n; j++) {
  142.      if (!cnv:integer(i[j],i[j]))
  143.             runerr(101,i[j]);
  144.      if ((j>0) && IntVal(i[j])<=IntVal(i[j-1]))
  145.             runerr(210, i[j]);
  146.          }
  147.       /*
  148.        * Start out assuming the result will be the same size as the argument.
  149.        */
  150.       Protect(StrLoc(result) = alcstr(NULL, StrLen(s)), runerr(0));
  151.       StrLen(result) = StrLen(s);
  152.  
  153.       /*
  154.        * Copy the string, expanding tabs.
  155.        */
  156.       last = 1;
  157.       if (n == 0)
  158.          interval = 8;
  159.       else {
  160.          if (!cnv:integer(i[0], i[0]))
  161.             runerr(101, i[0]);
  162.          if (IntVal(i[0]) <= last)
  163.             runerr(210, i[0]);
  164.           }
  165.       tablst = i;
  166.       endlst = &i[n];
  167.       col = 1;
  168.       iend = StrLoc(s) + StrLen(s);
  169.       for (in = StrLoc(s), out = StrLoc(result); in < iend; ) 
  170.          switch (c = *out++ = *in++) {
  171.             case '\b':
  172.                col--;
  173.                tablst = i;  /* reset the list of remaining tab stops */
  174.                last = 1;
  175.                break;
  176.             case LineFeed:
  177.             case CarriageReturn:
  178.                col = 1;
  179.                tablst = i;  /* reset the list of remaining tab stops */
  180.                last = 1;
  181.                break;
  182.             case '\t':
  183.                is_expanded = 1;
  184.                out--;
  185.                target = col;
  186.                nxttab(&target, &tablst, endlst, &last, &interval);
  187.                expand = target - col - 1;
  188.                if (expand > 0) {
  189.                   Protect(alcstr(NULL, expand), runerr(0));
  190.                   StrLen(result) += expand;
  191.                   }
  192.                while (col < target) {
  193.                   *out++ = ' ';
  194.                   col++;
  195.                   }
  196.                break;
  197.             default:
  198.                if (isprint(c))
  199.                   col++;
  200.             }
  201.  
  202.       /*
  203.        * Return new string if indeed there were tabs; otherwise return original
  204.        *  string to conserve memory.
  205.        */
  206.       if (is_expanded)
  207.          return result;
  208.       else {
  209.      MMStr(DiffPtrs(StrLoc(result),strfree)); /* note the deallocation */
  210.      strtotal += DiffPtrs(StrLoc(result),strfree);
  211.          strfree = StrLoc(result);        /* reset the free pointer */
  212.          return s;                /* return original string */
  213.          }
  214.       }
  215. end
  216.  
  217.  
  218. "entab(s,i,...) - replace spaces with tabs, with stops at columns indicated."
  219.  
  220. function{1} entab(s,i[n])
  221.    if !cnv:string(s) then
  222.       runerr(103,s)
  223.  
  224.    abstract {
  225.       return string
  226.       }
  227.  
  228.    body {
  229.       C_integer last, interval, col, target, nt, nt1, j;
  230.       dptr tablst;
  231.       dptr endlst;
  232.       char *in, *out, *iend;
  233.       char c;
  234.       int inserted = 0;
  235.  
  236.       for (j=0; j<n; j++) {
  237.      if (!cnv:integer(i[j],i[j]))
  238.             runerr(101,i[j]);
  239.      if ((j>0) && IntVal(i[j])<=IntVal(i[j-1]))
  240.             runerr(210, i[j]);
  241.          }
  242.  
  243.       /*
  244.        * Get memory for result at end of string space.  We may give some back
  245.        *  if not all needed, or all of it if no tabs can be inserted.
  246.        */
  247.       Protect(StrLoc(result) = alcstr(NULL, StrLen(s)), runerr(0));
  248.       StrLen(result) = StrLen(s);
  249.  
  250.       /*
  251.        * Copy the string, looking for runs of spaces.
  252.        */
  253.       last = 1;
  254.       if (n == 0)
  255.          interval = 8;
  256.       else {
  257.          if (!cnv:integer(i[0], i[0]))
  258.             runerr(101, i[0]);
  259.          if (IntVal(i[0]) <= last)
  260.             runerr(210, i[0]);
  261.          }
  262.       tablst = i;
  263.       endlst = &i[n];
  264.       col = 1;
  265.       target = 0;
  266.       iend = StrLoc(s) + StrLen(s);
  267.  
  268.       for (in = StrLoc(s), out = StrLoc(result); in < iend; )
  269.          switch (c = *out++ = *in++) {
  270.          case '\b':
  271.             col--;
  272.             tablst = i;  /* reset the list of remaining tab stops */
  273.             last = 1;
  274.             break;
  275.          case LineFeed:
  276.          case CarriageReturn:
  277.             col = 1;
  278.             tablst = i;  /* reset the list of remaining tab stops */
  279.             last = 1;
  280.             break;
  281.          case '\t':
  282.             nxttab(&col, &tablst, endlst, &last, &interval);
  283.             break;
  284.          case ' ':
  285.             target = col + 1;
  286.             while (in < iend && *in == ' ')
  287.                target++, in++;
  288.             if (target - col > 1) { /* never tab just 1; already copied space */
  289.                nt = col;
  290.                nxttab(&nt, &tablst, endlst, &last, &interval);
  291.                if (nt == col+1) {
  292.                   nt1 = nt;
  293.                   nxttab(&nt1, &tablst, endlst, &last, &interval);
  294.                   if (nt1 > target) {
  295.                      col++;    /* keep space to avoid 1-col tab then spaces */
  296.                      nt = nt1;
  297.                      }
  298.                   else
  299.                      out--;    /* back up to begin tabbing */
  300.                   }
  301.                else
  302.                   out--;    /* back up to begin tabbing */
  303.                while (nt <= target)  {
  304.                   inserted = 1;
  305.                   *out++ = '\t';    /* put tabs to tab positions */
  306.                   col = nt;
  307.                   nxttab(&nt, &tablst, endlst, &last, &interval);
  308.                   }
  309.                while (col++ < target)
  310.                   *out++ = ' ';        /* complete gap with spaces */
  311.                }
  312.             col = target;
  313.             break;
  314.          default:
  315.             if (isprint(c))
  316.                col++;
  317.          }
  318.  
  319.       /*
  320.        * Return new string if indeed tabs were inserted; otherwise return
  321.        *  original string (and reset strfree) to conserve memory.
  322.        */
  323.       if (inserted) {
  324.          StrLen(result) = DiffPtrs(out,StrLoc(result));
  325.      MMStr(DiffPtrs(out,strfree));        /* note the deallocation */
  326.      strtotal += DiffPtrs(out,strfree);
  327.          strfree = out;                /* give back unused space */
  328.          return result;                /* return new string */
  329.          }
  330.       else {
  331.      MMStr(DiffPtrs(StrLoc(result),strfree)); /* note the deallocation */
  332.      strtotal += DiffPtrs(StrLoc(result),strfree);
  333.          strfree = StrLoc(result);        /* reset free pointer */
  334.          return s;                /* return original string */
  335.      }
  336.       }
  337. end      
  338.  
  339. /*
  340.  * nxttab -- helper routine for entab and detab, returns next tab
  341.  *   beyond col
  342.  */
  343.  
  344. void nxttab(col, tablst, endlst, last, interval)
  345. C_integer *col;
  346. dptr *tablst;
  347. dptr endlst;
  348. C_integer *last;
  349. C_integer *interval;
  350.    {
  351.    /*
  352.     * Look for the right tab stop.
  353.     */
  354.    while (*tablst < endlst && *col >= IntVal((*tablst)[0])) {
  355.       ++*tablst;
  356.       if (*tablst == endlst)
  357.          *interval = IntVal((*tablst)[-1]) - *last;
  358.       else {
  359.          *last = IntVal((*tablst)[-1]);
  360.          }
  361.       }
  362.    if (*tablst >= endlst) 
  363.       *col = *col + *interval - (*col - *last) % *interval;
  364.    else
  365.       *col = IntVal((*tablst)[0]);
  366.    }
  367.  
  368.  
  369. "left(s1,i,s2) - pad s1 on right with s2 to length i."
  370.  
  371. function{1} left(s1,n,s2)
  372.    FstrSetup  /* includes body { */
  373.  
  374.       /*
  375.        * If we are extracting the left part of a large string (not padding),
  376.        * just construct a descriptor.
  377.        */
  378.       if (n <= StrLen(s1)) {
  379.      return string(n, StrLoc(s1));
  380.          }
  381.  
  382.       /*
  383.        * Get n bytes of string space.  Start at the right end of the new
  384.        *  string and copy s2 into the new string as many times as it fits.
  385.        *  Note that s2 is copied from right to left.
  386.        */
  387.       Protect(sbuf = alcstr(NULL, n), runerr(0));
  388.  
  389.       slen = StrLen(s2);
  390.       s3 = StrLoc(s2);
  391.       s = sbuf + n;
  392.       while (s > sbuf) {
  393.          st = s3 + slen;
  394.          while (st > s3 && s > sbuf)
  395.             *--s = *--st;
  396.          }
  397.  
  398.       /*
  399.        * Copy up to n bytes of s1 into the new string, starting at the left end
  400.        */
  401.       s = sbuf;
  402.       slen = StrLen(s1);
  403.       st = StrLoc(s1);
  404.       if (slen > n)
  405.          slen = n;
  406.       while (slen-- > 0)
  407.          *s++ = *st++;
  408.  
  409.       /*
  410.        * Return the new string.
  411.        */
  412.       return string(n, sbuf);
  413.       }
  414. end
  415.  
  416.  
  417. "map(s1,s2,s3) - map s1, using s2 and s3."
  418.  
  419. function{1} map(s1,s2,s3)
  420.    /*
  421.     * s1 must be a string; s2 and s3 default to (string conversions of)
  422.     *  &ucase and &lcase, respectively.
  423.     */
  424.    if !cnv:string(s1) then
  425.       runerr(103,s1)
  426. #if COMPILER
  427.    if !def:string(s2, ucase) then
  428.       runerr(103,s2)
  429.    if !def:string(s3, lcase) then
  430.       runerr(103,s3)
  431. #endif                        /* COMPILER */
  432.  
  433.    abstract {
  434.       return string
  435.       }
  436.    body {
  437.       register int i;
  438.       register word slen;
  439.       register char *str1, *str2, *str3;
  440.       static char maptab[256];
  441.  
  442. #if !COMPILER
  443.       if (is:null(s2))
  444.          s2 = ucase;
  445.       if (is:null(s3))
  446.          s3 = lcase;
  447. #endif                    /* !COMPILER */
  448.       /*
  449.        * If s2 and s3 are the same as for the last call of map,
  450.        *  the current values in maptab can be used. Otherwise, the
  451.        *  mapping information must be recomputed.
  452.        */
  453.       if (!EqlDesc(maps2,s2) || !EqlDesc(maps3,s3)) {
  454.          maps2 = s2;
  455.          maps3 = s3;
  456.  
  457. #if !COMPILER
  458.          if (!cnv:string(s2,s2))
  459.             runerr(103,s2);
  460.          if (!cnv:string(s3,s3))
  461.             runerr(103,s3);
  462. #endif                    /* !COMPILER */
  463.          /*
  464.           * s2 and s3 must be of the same length
  465.           */
  466.          if (StrLen(s2) != StrLen(s3)) 
  467.             runerr(208);
  468.  
  469.          /*
  470.           * The array maptab is used to perform the mapping.  First,
  471.           *  maptab[i] is initialized with i for i from 0 to 255.
  472.           *  Then, for each character in s2, the position in maptab
  473.           *  corresponding to the value of the character is assigned
  474.           *  the value of the character in s3 that is in the same 
  475.           *  position as the character from s2.
  476.           */
  477.          str2 = StrLoc(s2);
  478.          str3 = StrLoc(s3);
  479.          for (i = 0; i <= 255; i++)
  480.             maptab[i] = i;
  481.          for (slen = 0; slen < StrLen(s2); slen++)
  482.             maptab[str2[slen]&0377] = str3[slen];
  483.          }
  484.  
  485.       if (StrLen(s1) == 0) {
  486.          return emptystr;
  487.          }
  488.  
  489.       /*
  490.        * The result is a string the size of s1; create the result
  491.        *  string, but specify no value for it.
  492.        */
  493.       StrLen(result) = slen = StrLen(s1);
  494.       Protect(StrLoc(result) = alcstr(NULL, slen), runerr(0));
  495.       str1 = StrLoc(s1);
  496.       str2 = StrLoc(result);
  497.  
  498.       /*
  499.        * Run through the string, using values in maptab to do the
  500.        *  mapping.
  501.        */
  502.       while (slen-- > 0)
  503.          *str2++ = maptab[(*str1++)&0377];
  504.  
  505.       return result;
  506.       }
  507. end
  508.  
  509.  
  510. "repl(s,i) - concatenate i copies of string s."
  511.  
  512. function{1} repl(s,n)
  513.  
  514.    if !cnv:string(s) then
  515.       runerr(103,s)
  516.  
  517.    if !cnv:C_integer(n) then
  518.       runerr(101,n)
  519.  
  520.    abstract {
  521.        return string
  522.        }
  523.  
  524.    body {
  525.       register C_integer cnt;
  526.       register C_integer slen;
  527.       register C_integer size;
  528.       register char * resloc, * sloc, *floc;
  529.  
  530.       if (n < 0) {
  531.          irunerr(205,n);
  532.          errorfail;
  533.          }
  534.  
  535.       slen = StrLen(s);
  536.       /*
  537.        * Return an empty string if n is 0 or if s is the empty string.
  538.        */
  539.       if ((n == 0) || (slen==0))
  540.          return emptystr;
  541.  
  542.       /*
  543.        * Make sure the resulting string will not be too long.
  544.        */
  545.       size = n * slen;
  546.       if (size > MaxStrLen) {
  547.          irunerr(205,n);
  548.          errorfail;
  549.          }
  550.  
  551.       /*
  552.        * Make result a descriptor for the replicated string.
  553.        */
  554.       Protect(resloc = alcstr(NULL, size), runerr(0));
  555.  
  556.       StrLoc(result) = resloc;
  557.       StrLen(result) = size;
  558.  
  559.       /*
  560.        * Fill the allocated area with copies of s.
  561.        */
  562.       sloc = StrLoc(s);
  563.       if (slen == 1)
  564.          memfill(resloc, *sloc, size);
  565.       else {
  566.          while (--n >= 0) {
  567.             floc = sloc;
  568.             cnt = slen;
  569.             while (--cnt >= 0)
  570.                *resloc++ = *floc++;
  571.             }
  572.          }
  573.  
  574.       return result;
  575.       }
  576. end
  577.  
  578.  
  579. "reverse(s) - reverse string s."
  580.  
  581. function{1} reverse(s)
  582.  
  583.    if !cnv:string(s) then
  584.       runerr(103,s)
  585.  
  586.    abstract {
  587.       return string
  588.       }
  589.    body {
  590.       register char c, *floc, *lloc;
  591.       register word slen;
  592.  
  593.       /*
  594.        * Allocate a copy of s.
  595.        */
  596.       slen = StrLen(s);
  597.       Protect(StrLoc(result) = alcstr(StrLoc(s), slen), runerr(0));
  598.       StrLen(result) = slen;
  599.  
  600.       /*
  601.        * Point floc at the start of s and lloc at the end of s.  Work floc
  602.        *  and sloc along s in opposite directions, swapping the characters
  603.        *  at floc and lloc.
  604.        */
  605.       floc = StrLoc(result);
  606.       lloc = floc + --slen;
  607.       while (floc < lloc) {
  608.          c = *floc;
  609.          *floc++ = *lloc;
  610.          *lloc-- = c;
  611.          }
  612.       return result;
  613.       }
  614. end
  615.  
  616.  
  617. "right(s1,i,s2) - pad s1 on left with s2 to length i."
  618.  
  619. function{1} right(s1,n,s2)
  620.    FstrSetup  /* includes body { */
  621.       /*
  622.        * If we are extracting the right part of a large string (not padding),
  623.        * just construct a descriptor.
  624.        */
  625.       if (n <= StrLen(s1)) {
  626.      return string(n, StrLoc(s1) + StrLen(s1) - n);
  627.          }
  628.  
  629.       /*
  630.        * Get n bytes of string space.  Start at the left end of the new
  631.        *  string and copy s2 into the new string as many times as it fits.
  632.        */
  633.       Protect(sbuf = alcstr(NULL, n), runerr(0));
  634.  
  635.       slen = StrLen(s2);
  636.       s3 = StrLoc(s2);
  637.       s = sbuf;
  638.       while (s < sbuf + n) {
  639.          st = s3;
  640.          while (st < s3 + slen && s < sbuf + n)
  641.             *s++ = *st++;
  642.          }
  643.  
  644.       /*
  645.        * Copy s1 into the new string, starting at the right end and copying
  646.        * s2 from right to left.  If *s1 > n, only copy n bytes.
  647.        */
  648.       s = sbuf + n;
  649.       slen = StrLen(s1);
  650.       st = StrLoc(s1) + slen;
  651.       if (slen > n)
  652.          slen = n;
  653.       while (slen-- > 0)
  654.          *--s = *--st;
  655.  
  656.       /*
  657.        * Return the new string.
  658.        */
  659.       return string(n, sbuf);
  660.       }
  661. end
  662.  
  663.  
  664. "trim(s,c) - trim trailing characters in c from s."
  665.  
  666. function{1} trim(s,c)
  667.  
  668.    if !cnv:string(s) then
  669.       runerr(103, s)
  670.    /*
  671.     * c defaults to a cset containing a blank.
  672.     */
  673.    if !def:tmp_cset(c,blankcs) then
  674.       runerr(104, c)
  675.  
  676.    abstract {
  677.       return string
  678.       }
  679.  
  680.    body {
  681.       char *sloc;
  682.       C_integer slen;
  683.  
  684.       /*
  685.        * Start at the end of s and then back up until a character that is
  686.        *  not in c is found.  The actual trimming is done by having a
  687.        *  descriptor that points at a substring of s, but with the length
  688.        *  reduced.
  689.        */
  690.       slen = StrLen(s);
  691.       sloc = StrLoc(s) + slen - 1;
  692.       while (sloc >= StrLoc(s) && Testb(ToAscii(*sloc), c)) {
  693.          sloc--;
  694.          slen--;
  695.          }
  696.       return string(slen, StrLoc(s));
  697.       }
  698. end
  699.